home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / modlibsr.zoo / $assert.P < prev    next >
Text File  |  1989-07-05  |  10KB  |  282 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25. $assert_export([$assert/1,$asserta/1,$asserta/2,$assertz/1,$assertz/2,
  26.         $assert/2,$asserti/2,$assert/4,$assert_union/2,$assert_call_s/1,
  27.         $assert_get_prref/2,$assert_put_prref/2,$assert_abolish_i/1]).
  28.  
  29. /* $assert_use($meta,[$functor/3,$univ/2,$length/2]).
  30.    $assert_use($blist,[$append/3,$member/2,$memberchk/2]).
  31.    $assert_use($buff,
  32.     [$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,$symtype/2,
  33.         $substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  34.         $pred_undefined/1, $hashval/3]).
  35.    $assert_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  36.     $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,
  37.     $seen/0]).
  38.    $assert_use($db,[$db_new_prref/1,$db_assert_fact/5, $db_assert_fact/6,$db_assert_fact/7,
  39.            $db_assert_fact/8, $db_add_clref/6,
  40.         $db_call_prref/2,$db_call_prref_s/2,$db_call_prref_s/3,
  41.         $db_call_clref/2,$db_get_clauses/3,$db_kill_clause/1]).
  42. */
  43.  
  44. $assert_exp_cut((Head:-Body),(Nhead:-Nbody)) :- !,
  45.     $univ(Head,Hlist),$append(Hlist,[Cutpoint],Nhlist),
  46.     $univ(Nhead,Nhlist),
  47.     $assert_exp_cutb(Body,Nbody,Cutpoint).
  48.  
  49. $assert_exp_cut(Head,Head). /* leave unchanged, Arity is one less */
  50.  
  51. $assert_exp_cutb(X,call(X),_) :- var(X),!.
  52. $assert_exp_cutb(!,'_$cutto'(Cutpoint),Cutpoint) :- !.
  53. $assert_exp_cutb((A,B,C,D),','(Na,Nb,Nc,Nd),Cutpoint) :- !, /* opt */
  54.     $assert_exp_cutb(A,Na,Cutpoint),
  55.     $assert_exp_cutb(B,Nb,Cutpoint),
  56.     $assert_exp_cutb(C,Nc,Cutpoint),
  57.     $assert_exp_cutb(D,Nd,Cutpoint).
  58. $assert_exp_cutb((A,B),(Na,Nb),Cutpoint) :- !,
  59.     $assert_exp_cutb(A,Na,Cutpoint),
  60.     $assert_exp_cutb(B,Nb,Cutpoint).
  61. $assert_exp_cutb((A;B),(Na;Nb),Cutpoint) :- !,
  62.     $assert_exp_cutb(A,Na,Cutpoint),
  63.     $assert_exp_cutb(B,Nb,Cutpoint).
  64. $assert_exp_cutb((A->B),(A->Nb),Cutpoint) :- !,
  65.     $assert_exp_cutb(B,Nb,Cutpoint).
  66. $assert_exp_cutb(X,X,_).
  67.  
  68. $assert(Clause) :-
  69.      $assert_get_index(Clause,Index),
  70.      $assert(Clause,1,Index,_,1).
  71.  
  72. $asserta(Clause) :- $assert(Clause,0,0,_,1).
  73. $asserta(Clause,Ref) :- $assert(Clause,0,0,Ref,1).
  74.  
  75. $assertz(Clause) :-
  76.      $assert_get_index(Clause,Index),
  77.      $assert(Clause,1,Index,_,1).
  78. $assertz(Clause,Ref) :-
  79.      $assert_get_index(Clause,Index),
  80.      $assert(Clause,1,Index,Ref,1).
  81.  
  82. $assert(Clause,Clref) :-
  83.      $assert_get_index(Clause,Index),
  84.      $assert(Clause,1,Index,Clref,1).
  85.  
  86. $asserti(Clause,Index) :- $assert(Clause,1,Index,_,1).
  87.  
  88. $assert(Clause, AZ, Index, Clref) :-
  89.     $assert(Clause, AZ, Index, Clref, 1).
  90.  
  91. $assert(Clause, AZ, Index, Clref,Flatten) :-
  92.     $assert_exp_cut(Clause,Nclause), /* write(Nclause),nl, */
  93.     $assert_cvt_dyn(Clause,Prref,Where,Supbuff),
  94.     $db_assert_fact(Nclause,Prref,AZ,Index,Clref,Flatten,Where,Supbuff).
  95.  
  96. $assert_get_index(Clause,Index) :-
  97.      (Clause \= (_ :- _) ->
  98.           ($functor0(Clause,P), $arity(Clause,N)) ;
  99.       (arg(1,Clause,Hd), $functor0(Hd,P), $arity(Hd,N))
  100.      ),
  101.      (($symtype('_$index'(_,_,_),IType),
  102.        IType > 0,
  103.        '_$index'(P,N,Index)
  104.       ) ->
  105.            true ;
  106.        Index = 1
  107.      ).
  108.      
  109.  
  110. /* this is a translator for facts. It takes a term that represents 
  111.    a predicate call (a fact) and generates and writes the code 
  112.    corresponding to the fact into a buffer. It then asserts the fact 
  113.    by adding it to the end of the tryme-retryme-trustme sequence for
  114.    the main predicate of the fact.
  115. */
  116.  
  117.  
  118. /* $assert(Fact,AZ,Index,Clref):  asserts a fact to a fact-defined 
  119. predicate. Fact is the fact to assert. AZ is 0 for insertion as the
  120. first clause; 1 for insertion as the last clause. Index is the number of 
  121. the argument on which to index; 0 for no indexing. Clref is returned as
  122. the clause reference of the fact newly asserted. */
  123.  
  124.  
  125. $assert_cvt_dyn(Clause,Prref,Where,Supbuff) :-
  126.     (Clause = (Fact:-B),! ; Clause=Fact),
  127.     $symtype(Fact, SYMTYPE),
  128.     (SYMTYPE =:= 1 ->        /* already dynamic */
  129.       $assert_get_prref(Fact,Prref,Where,Supbuff)
  130.       ;
  131.       Where = 0,
  132.       (SYMTYPE =:= 0 ->        /* undefined, this is first clause */
  133.         $db_new_prref(Prref),
  134.         $assert_put_prref(Fact,Prref)
  135.         ;
  136.         (SYMTYPE =:= 2 ->        /* compiled, so convert */
  137.           $assert_cvt_buff(Fact,Ccls),
  138.           $db_new_prref(Prref),
  139.           $assert_put_prref(Fact,Prref),
  140.           $arity(Fact,Arity1),Arity is Arity1+1,
  141.           $db_add_clref(Fact,Arity,Prref,1,0,Ccls)
  142.           ;
  143.           $writename('Error, cannot assert into Buffer'),$nl,fail
  144.         )
  145.       )
  146.     ).
  147.  
  148.  
  149. /* return a buffer with a branch to the clauses for Fact */
  150. $assert_cvt_buff(Fact,Tbuff) :-
  151.     $alloc_perm(16,Tbuff),   /* buff to convert to dynamic */
  152.     $buff_code(Tbuff,0,14 /*ptv*/ ,Tbuff),    /* back ptr */
  153.     $buff_code(Tbuff,10,3 /*pb*/ ,240 /*jump*/ ),
  154.     $buff_code(Tbuff,11,3 /*pb*/ ,0),
  155.     $buff_code(Tbuff,12,20 /*pepb*/ ,Fact).
  156.  
  157.  
  158. /* assert_union adds the clauses of the second predicate
  159.    to the first predicate. E.g., given p(X,Y) and q(X,Y), it adds the rule
  160.    p(X,Y) :- q(X,Y) as the last rule defining p. If p is not defined, then
  161.    it results in the call of q being the only clause for p */
  162.  
  163. $assert_union(P,Q) :- 
  164.     $assert_cvt_buff(Q,Qclref),
  165.     $assert_cvt_dyn(P,Prref,0,0),
  166.     $arity(P,Arity1),Arity is Arity1+1,
  167.     $db_add_clref(P,Arity,Prref,1,0,Qclref).
  168.     
  169. /* This defines routines that can be used to assert facts onto the heap.
  170. */
  171.  
  172. /* We have introduced a new simulator instruction similar  to the one
  173. used to translate variables in globalset.  It is a branch
  174. instruction, called executev.  It  derefs its  argument and  if it is
  175. not a variable, does an execute to main functor symbol.  (Execute has
  176. been modified so that when a buffer is called, it branches  to disp 4
  177. in the name.)  If it  is a  variable, it  gives an  error message and
  178. fails.  */ 
  179.  
  180. /* $assert_new_t_prref(Call,Prref,Supbuff):  Call must be
  181. instantiated to a term (just used for getting psc).  If  that psc has
  182. no e.p.  then this creates a permanent buffer  containing an executev
  183. instruction, and the constant  for the  Supbuff, and  points the e.p.
  184. of Call to it.  A Prref is allocated and  the target  of the executev
  185. is set to that.  If the psc already has an e.p., the predicate fails.
  186. */ 
  187.  
  188. $assert_new_t_prref(Call,Prref,Supbuff) :-
  189.     $symtype(Call,Type),
  190.     (Type =:= 1,    /* dynamic */
  191.      $buff_code(Call,0,7 /*gepb*/ ,Vbuff),
  192.      $buff_code(Vbuff,4,6 /*gb*/ ,249 /*noop*/ ),
  193.      $buff_code(Vbuff,5,6,0),
  194.      $buff_code(Vbuff,6,6,238 /* executev */ ),
  195.      $buff_code(Vbuff,8,18 /*ubv*/ ,Prref),
  196.      $db_new_prref(Prref,2,Supbuff),
  197.      $buff_code(Vbuff,12,18 /*ubv*/ ,Supbuff),
  198.      !
  199.     ;
  200.      $buff_code(Call,0,11,0), /* this overrides everything!! */
  201.      /* allocate new executev instruction, and supbuff ptr */
  202.      $alloc_perm(16,Vbuff), /* must make permanent */
  203.      $buff_code(Vbuff,0,14,Vbuff), /* set back ptr */
  204.      $buff_code(Call,0,9 /*pep*/ ,Vbuff),
  205.      $buff_code(Vbuff,4,3 /*pb*/ ,249 /*noop*/ ),
  206.      $buff_code(Vbuff,5,3,0),
  207.      $buff_code(Vbuff,6,3,238 /* executev */ ),
  208.      $buff_code(Vbuff,7,3,0),
  209.      $buff_code(Vbuff,8,12 /*fv*/ ,0),
  210.      $buff_code(Vbuff,12,12 /*fv*/ ,0),
  211.      $db_new_prref(Prref,2,Supbuff),
  212.      $buff_code(Vbuff,8,18 /*ubv*/ ,Prref),
  213.      $buff_code(Vbuff,12,18 /*ubv*/ ,Supbuff)
  214.     ).
  215.  
  216.  
  217. /* $assert_alloc_t must be called first to declare that a predicate (or set
  218. of predicates) are to have facts asserted into them on the  heap.  It
  219. is given a list of Pred/Arity pairs and a size.  That  amount of heap
  220. space is reserved for facts to  be asserted  to these  predicates.  A
  221. temporary prref buffer is created.  */ 
  222.  
  223. $assert_alloc_t(Palist,Size) :- 
  224.     $alloc_heap(Size,Sbuff),
  225.     $assert_alloc_t1(Palist,Sbuff).
  226.  
  227. $assert_alloc_t1([],_).
  228. $assert_alloc_t1([F|R],Supbuff) :- 
  229.     $assert_alloc_t1(F,Supbuff),$assert_alloc_t1(R,Supbuff).
  230. $assert_alloc_t1(P/A,Supbuff) :-
  231.     $bldstr(P,A,Term),
  232.     $assert_new_t_prref(Term,Prref,Supbuff).
  233.  
  234.  
  235.  
  236. $assert_call_s(Goal) :- 
  237.     $assert_get_prref(Goal,Prref,_,_),$db_call_prref_s(Goal,Prref).
  238.  
  239.  
  240. /* $assert_get_prref(Fact,Prref,Where,Supbuff):  where Fact is a
  241. literal, which should be dynamic. The e.p. field of the main functor
  242. symbol of Fact points to either a permanent prref, or a execv buffer
  243. that points to a temporary prref. If it is a permanent prref, Where
  244. is returned as 0; if a temporary, Where is set to 2, and Supbuff is
  245. bound to the superbuffer containing the clauses. */
  246.  
  247. $assert_get_prref(Fact,Prref) :- $assert_get_prref(Fact,Prref,_,_).
  248. $assert_get_prref(Fact,Prref,Where,Supbuff) :-
  249.     $symtype(Fact,Type),
  250.     (Type =:= 1 ->    /*DYNA: must be dynamic */
  251.         $buff_code(Fact,0,7 /*gepb*/ ,Vbuff),
  252.          ($buff_code(Vbuff,4,6 /*pb*/ ,249 /*noop*/ ),
  253.           $buff_code(Vbuff,5,6,0),
  254.           $buff_code(Vbuff,6,6,238 /* executev */ ),
  255.           Where=2,
  256.           $buff_code(Vbuff,8,18 /*ubv*/ ,Prref),
  257.           $buff_code(Vbuff,12,18 /*ubv*/ ,Supbuff),
  258.           !
  259.          ;
  260.           Prref=Vbuff,Where=0
  261.          )
  262.         ;
  263.          Type =\= 0, /* if undefined, just fail */
  264.          $writename('Error, Illegal Predicate ref: '),
  265.          $write(Fact),$nl,fail
  266.     ).
  267.  
  268. /* $assert_put_prref(Fact,Prref):  where Fact is a literal and Prref
  269. is an prref.  Prref must  be bound  to an  existing prref.   The e.p.
  270. field of the psc entry for the main functor symbol of Fact  is set to
  271. point to the Prref.  */ 
  272.  
  273. $assert_put_prref(Fact,Prref) :-
  274.     $buff_code(Fact,0,9 /*pep*/ ,Prref).
  275.  
  276. /* $assert_abolish_i(Fact): initializes the predicate that is the main 
  277. functor symbol of Fact to be empty, by allocating a new empty Prref and 
  278. assigning it. */
  279.  
  280. $assert_abolish_i(Fact) :- 
  281.     $db_new_prref(Prref),$assert_put_prref(Fact,Prref).
  282.